home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGSCAL / TPSOURCE.LZH / PTOOLDAT.INC < prev    next >
Text File  |  1985-02-21  |  36KB  |  1,016 lines
  1. { PTOOLDAT.INC   Copyright 1984  R D Ostrander                   Version 1.0
  2.                                  Ostrander Data Services
  3.                                  5437 Honey Manor Dr
  4.                                  Indianapolis  IN  46241
  5.  
  6.  These Turbo Pascal functions are date manipulation tools used to Convert
  7.  Gregorian date strings, Change Gregorian Dates to and from Julian dates,
  8.  Find Day of Week, Add numbers to dates, Find the difference between dates,
  9.  Convert dates to 2 byte integers in order to save disk storage, and to
  10.  Retrieve the current (system) date. Handles date from 1/1/0100 to 12/31/9999.
  11.  
  12.  This program has been placed in the Public Domain by the author and copies
  13.  may be freely made for non-commercial, demonstration, or evaluation purposes.
  14.  Use of these subroutines in a program for sale or for commercial purposes in
  15.  a place of business requires a $20 fee be paid to the author at the address
  16.  above.  Personal non-commercial users may also elect to pay the $20 fee to
  17.  encourage further development of this and similar programs. With payment you
  18.  will be able to receive update notices, diskettes and printed documentation
  19.  of this and other PTOOLs from Ostrander Data Services.
  20.  
  21.  PTOOL, and PTOOLxxx are Copyright Trademarks of Ostrander Data Services
  22.  
  23.  Turbo Pascal is a Copyright of Borland International Inc.
  24.  
  25. Functions available in PTOOLDAT.INC are:
  26.  
  27.                                (Result)
  28.  
  29.  PTDGValid (String)          : Boolean - True if argument is valid Gregorian
  30.                                          Date
  31.  PTDJValid (Real)            : Boolean - True if argument is valid Julian Date
  32.                                          (Note that this is useful for
  33.                                           Julian types A & B (ANSI) only)
  34.  PTDSValid (Integer)         : Boolean - True if argument is valid Short
  35.                                          format Date
  36.  PTDGtoJ   (String)          : Real    - Convert argument (Gregorian Date) to
  37.                                          a Julian Date
  38.  PTDJtoG   (Real)            : String  - Convert argument (Julian Date) to a
  39.                                          Gregorian Date
  40.  PTDGtoG   (String)          : String  - Convert argument (Gregorian Date in
  41.                                          2nd format) to Gregorian Date in
  42.                                          standard (1st) format - Note that
  43.                                          a blank (space filled) string
  44.                                          returned if the argument cannot be
  45.                                          converted
  46.  PTDGtoS   (String)          : Integer - Convert argument (Gregorian Date to
  47.                                          a Short format date. Return -32766 if
  48.                                          not in range of January 1st of Base
  49.                                          year thru June 1st, 179 years after
  50.                                          the Base Year.
  51.  PTDStoG   (Integer)         : String  - Convert argument (Short format Date)
  52.                                          to a Gregorian Date
  53.  PTDJtoS   (Real)            : Integer - Convert argument (Julian Date to
  54.                                          a Short format date
  55.  PTDStoJ   (Integer)         : Real    - Convert argument (Short format Date)
  56.                                          to a Julian Date
  57.  PTDGAdd   (String, Integer) : String  - Add argument-2 (Integer) number of
  58.                                          days to argument-1 (Gregorian Date)
  59.                                          and express result in Gregorian
  60.                                          format
  61.  PTDJAdd   (Real, Integer)   : Real    - Add argument-2 (Integer) number of
  62.                                          days to argument-1 (Julian Date) and
  63.                                          express result in Julian format
  64.  PTDGComp  (String, String)  : Real    - Subtract argument-2 (Gregorian Date)
  65.                                          from argument-1 (Gregorian Date)
  66.                                          giving number of days between dates
  67.                                          minus 1.
  68.  PTDJComp  (Real, Real)      : Real    - Subtract argument-2 (Julian Date)
  69.                                          from argument-1 (Julian Date) giving
  70.                                          number of days between dates minus 1
  71.  PTDGLeap  (String)          : Boolean - True if argument (Gregorian Date) is
  72.                                          a Leap Year
  73.  PTDJLeap  (Real)            : Boolean - True if argument (Julian Date) is a
  74.                                          Leap Year
  75.  PTDSLeap  (Integer)         : Boolean - True if argument (Short format date)
  76.                                          is a Leap Year
  77.  PTDYLeap  (Integer)         : Boolean - True if argument is a Leap Year
  78.  PTDGDay   (String)          : String  - Return Day of Week for argument
  79.                                          (Gregorian Date)
  80.  PTDJDay   (Real)            : String  - Return Day of Week for argument
  81.                                          (Julian Date)
  82.  PTDSDay   (Integer)         : String  - Return Day of Week for argument
  83.                                          (Short format date)
  84.  PTDGCurr                    : String  - Current (system) Gregorian Date
  85.  PTDJCurr                    : Real    - Current (system) Julian Date
  86.  PTDSCurr                    : Integer - Current (system) Short format date }
  87.  
  88.  
  89. { Constants and Parameters Begin Here ************************************* }
  90.  
  91.  
  92. TYPE
  93.  
  94.      PTOOLDAT_Str_21   = String [21];                    {Gregorian Dates    }
  95.      PTOOLDAT_Str_3    = String [3];                     {Order of elements  }
  96.      PTOOLDAT_Str_9    = String [9];                     {Day of Week        }
  97.      PTOOLDAT_Elements = Array [1..3]  of String [21];   {Parsing elements   }
  98.      PTOOLDAT_Numbers  = Array [1..3]  of Integer;       {Parsing numbers    }
  99.      PTOOLDAT_Months   = Array [1..12] of String [9];    {Months Names       }
  100.      PTOOLDAT_Days     = Array [1..7]  of PTOOLDAT_Str_9;{Days of the Week   }
  101.  
  102.  
  103. CONST
  104.  
  105.    { Gregorian Date      A string expression of up to 21 characters.
  106.      --------------      example:  02/15/50  or  February 2, 1950
  107.  
  108.                          The order and style to display the elements
  109.                          (Month, Day, Year) are determined by the
  110.                          parameters below.
  111.  
  112.                          As an argument, the date is passed as a string
  113.                          expression with 3 elements in the same order as
  114.                          displayed separated by at least one of the
  115.                          characters  / - , . ' ; : ( )  or a space.      }
  116.  
  117.                                            {    Gregorian Date parameters    }
  118.                                            {*********************************}
  119.  PTOOLDAT_G_YrDisp  : Byte        = 2;     { # of Display Chars for Year     }
  120.                                            {     2    = 50                   }
  121.                                            {     4    = 1950                 }
  122.  PTOOLDAT_G_MoDisp  : Byte        = 2;     { # of Display Chars for Month    }
  123.                                            {     2    = 02                   }
  124.                                            {     3    = Feb                  }
  125.                                            {     9    = February             }
  126.  PTOOLDAT_G_DaDisp  : Byte        = 2;     { # of Display Chars for Day      }
  127.                                            {     2    = 15                   }
  128.  PTOOLDAT_G_Order   : String [3]  = 'MDY'; { Order of Display                }
  129.                                            {     MDY  = 02 15 50             }
  130.  PTOOLDAT_G_Sep1    : String [3]  = '/';   { 1st Separation Character        }
  131.                                            {     /    = 02/15 50             }
  132.  PTOOLDAT_G_Sep2    : String [3]  = '/';   { 2nd Separation Character        }
  133.                                            {     /    = 02/15/50             }
  134.  PTOOLDAT_G_ZeroSup : Boolean     = True;  { Zero Suppress Display?          }
  135.                                            {     True =  2/15/50             }
  136.                                            {*********************************}
  137.  
  138.    { The 2nd Gregorian Date is used solely as input for
  139.      the conversion function PTDGtoG                    }
  140.  
  141.                                            {  2nd Gregorian Date parameters  }
  142.                                            {*********************************}
  143.  PTOOLDAT_G2_Order  : String [3]  = 'YMD'; { Order of Input                  }
  144.                                            {*********************************}
  145.  
  146.    { Julian Date      A Real number in either of three formats:
  147.      -----------      A = ANSI Date (YYDDD)  YY is the year within century
  148.                                             DDD is the day of the year
  149.                       B = ANSI Date (YYYYDDD) YYYY is the year
  150.                                               DDD  is the day of the year
  151.                       E = Elapsed days since January 1 of the base year below.
  152.                                Note that this may result in a negative number
  153.                                if the date is previous to the base year
  154.                           CAUTION - If the base year below is changed, this
  155.                                value becomes meaningless.
  156.  
  157.  
  158.  
  159.                                            {      Julian Date parameter      }
  160.                                            {*********************************}
  161.  PTOOLDAT_J_Type    : Char        = 'A';   { Julian Date Type                }
  162.                                            {     A    = ANSI Date (YYDDD)    }
  163.                                            {                      (50046)    }
  164.                                            {     B    = ANSI DATE (YYYYDDD)  }
  165.                                            {                      (1950046)  }
  166.                                            {     E    = Days since January   }
  167.                                            {                1st of base year }
  168.                                            {                      (7350)     }
  169.                                            {*********************************}
  170.  
  171.    { Short Date      An integer value representing the number of days since
  172.      ----------      January 1 of the base year below minus 32765. USE WITH
  173.                      CAUTION, dates earlier than the base year or later than
  174.                      179 years after the base year cannot be calculated (date
  175.                      returned is -32766). This date is useful for saving disk
  176.                      or table storage only - it must be changed back to
  177.                      another form to be used.
  178.  
  179.      Day of Week      A String expression of up to 9 characters
  180.      -----------      The format depends on the parameter below:
  181.  
  182.                 1 = 1      2      3       4         5        6      7
  183.                 3 = Sun    Mon    Tue     Wed       Thr      FrI    Sat
  184.                 9 = Sunday Monday Tuesday Wednesday Thursday Friday Saturday }
  185.  
  186.                                            {      Day of Week parameter      }
  187.                                            {*********************************}
  188.  PTOOLDAT_Day_Type  : Byte        = 3;     { Day of week Type                }
  189.                                            {     1    = 4                    }
  190.                                            {     2    = We                   }
  191.                                            {     3    = Wed                  }
  192.                                            {     9    = Wednesday            }
  193.                                            {*********************************}
  194.  
  195.     {Base Year        This is used for dates in Julian Type B format, for
  196.      ---------           conversion of dates entered without a century, and
  197.                          for Short format dates.
  198.                       If Base Year is 1930 then the year 50 will be calculated
  199.                          as 1950, the year 29 will be calculated as 2029.    }
  200.  
  201.  PTOOLDAT_BaseYear  : Integer     = 1930;
  202.  
  203. {*****   PTOOLDAT Internal usage fields follow:  *****}
  204.  
  205.  PTOOLDAT_Element   : PTOOLDAT_Elements = (' ', ' ', ' ');
  206.  PTOOLDAT_Number    : PTOOLDAT_Numbers  = (0, 0, 0);
  207.  PTOOLDAT_ElY       : String [9] = '         ';
  208.  PTOOLDAT_ElM       : String [9] = '         ';
  209.  PTOOLDAT_ElD       : String [9] = '         ';
  210.  PTOOLDAT_NumY      : Integer = 0;
  211.  PTOOLDAT_NumM      : Integer = 0;
  212.  PTOOLDAT_NumD      : Integer = 0;
  213.  
  214.  PTOOLDAT_Mon   : PTOOLDAT_Months    = ('Jan', 'Feb', 'Mar', 'Apr', 'May',
  215.                                         'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
  216.                                         'Nov', 'Dec');
  217.  PTOOLDAT_Month : PTOOLDAT_Months    = ('January', 'February', 'March',
  218.                                         'April', 'May', 'June', 'July',
  219.                                         'August', 'September', 'October',
  220.                                         'November', 'December');
  221.  PTOOLDAT_Day   : PTOOLDAT_Days      = ('Sun', 'Mon', 'Tue', 'Wed', 'Thr',
  222.                                         'Fri', 'Sat');
  223.  PTOOLDAT_DayOW : PTOOLDAT_Days      = ('Sunday', 'Monday', 'Tuesday',
  224.                                         'Wednesday', 'Thursday', 'Friday',
  225.                                         'Saturday');
  226.  
  227.  
  228. { Internal Functions Begin Here ******************************************* }
  229.  
  230.  
  231. Procedure PTOOLDAT_Parse (VAR Test               : PTOOLDAT_Str_21;
  232.                           VAR Number_of_Elements : Integer);
  233.  
  234. Var
  235.    I, J, E : Byte;                             { Get elements of input }
  236.                                                { Any of the characters }
  237. Begin                                          { below may seperate    }
  238.      I := 1;                                   { the elements.         }
  239.      For E := 1 to 3 do
  240.          Begin
  241.               While (Test [I] in
  242.                               ['/', '-', ',', '.', ';', ':', '(', ')', ' '])
  243.                 and (I <= Length (Test)) do
  244.                     I := I + 1;
  245.               J := 1;
  246.               While (not (Test [I] in
  247.                               ['/', '-', ',', '.', ';', ':', '(', ')', ' ']))
  248.                 and (I <= Length (Test)) do
  249.                     Begin
  250.                          PTOOLDAT_Element [E] [J] := Test [I];
  251.                          J := J + 1;
  252.                          I := I + 1;
  253.                          Number_of_Elements := E;
  254.                          PTOOLDAT_Element [E] [0] := Char (J - 1);
  255.                     End;
  256.          End;
  257.      While (Test [I] in ['/', '-', ',', '.', ';', ':', '(', ')', ' '])
  258.        and (I <= Length (Test)) do
  259.            I := I + 1;
  260.      If    (not (Test [I] in ['/', '-', ',', '.', ';', ':', '(', ')', ' ']))
  261.        and (I <= Length (Test)) then
  262.            Number_of_Elements := 4;
  263. End;
  264.  
  265.  
  266. Function PTOOLDAT_Set_Century (InYear : Integer) : Integer;
  267.  
  268. Var                                   { Add correct century based on Base }
  269.    Century : Integer;                 { Year - if less than then next     }
  270.                                       { century else same.                }
  271. Begin
  272.      Century := Trunc (Int ( PTOOLDAT_BaseYear / 100)) * 100;
  273.      If InYear >= PTOOLDAT_BaseYear - Century
  274.      then PTOOLDAT_Set_Century := Century + InYear
  275.      else PTOOLDAT_Set_Century := Century + InYear + 100;
  276. End;
  277.  
  278.  
  279. Function PTOOLDAT_GetNum (Test : PTOOLDAT_Str_21; MDY : Char) : Integer;
  280.  
  281. Var
  282.    Number    : Integer;                         { Get the number of the }
  283.    Code      : Integer;                         { Month, Day, or Year   }
  284.    I, J      : Byte;
  285.    Year      : Integer;
  286.    Century   : Integer;
  287.    Ch        : Char;
  288.    TestMon   : String [3];
  289.    TestMonth : String [9];
  290.  
  291. Begin
  292.      PTOOLDAT_GetNum := 0;
  293.      Number := 0;
  294.      Val (Test, Number, Code);
  295.      Case MDY of
  296.       'M' : If (Code = 0)
  297.            and (Number in [1..12]) then
  298.                PTOOLDAT_GetNum := Number
  299.             else
  300.                Begin
  301.                     For I := 1 to 21 do
  302.                         Begin
  303.                              Ch := Test [I];
  304.                              Test [I] := UpCase (Ch);
  305.                         End;
  306.                     For I := 1 to 12 do
  307.                         Begin
  308.                              For J := 1 to 3 do
  309.   { Check for    }               Begin
  310.   { alphabetic   }                    Ch := PTOOLDAT_Mon [I] [J];
  311.   { month inputs }                    TestMon [J] := UpCase (Ch);
  312.                                  End;
  313.                              For J := 1 to 9 do
  314.                                  Begin
  315.                                       Ch := PTOOLDAT_Month [I] [J];
  316.                                       TestMonth [J] := UpCase (Ch);
  317.                                  End;
  318.                              TestMon [0] := PTOOLDAT_Mon [I] [0];
  319.                              TestMonth [0] := PTOOLDAT_Month [I] [0];
  320.                              If (Test = TestMon)
  321.                              or (Test = TestMonth) then
  322.                                 PTOOLDAT_GetNum := I;
  323.                         End;
  324.                End;
  325.       'D' : If Code = 0 then
  326.                If Number in [1..31] then PTOOLDAT_GetNum := Number;
  327.       'Y' : If Code = 0 then
  328.                If Number > 99 then PTOOLDAT_GetNum := Number
  329.                  else
  330.                   PTOOLDAT_GetNum := PTOOLDAT_Set_Century (Number);
  331.       End; {Case}
  332. End;
  333.  
  334.  
  335. Function PTOOLDAT_Leap_Year (InYear : Integer) : Boolean;
  336.  
  337. Var                                          { Find out if it's a Leap Year }
  338.    Century : Integer;
  339.    Year    : Integer;
  340.  
  341. Begin
  342.      If InYear < 100 then
  343.         InYear := PTOOLDAT_Set_Century (InYear);
  344.      Century := Trunc (Int (InYear / 100));
  345.      Year := InYear - (Century * 100);
  346.      PTOOLDAT_Leap_Year := True;
  347.      If Year <> (Trunc (Int (Year / 4)) * 4) then PTOOLDAT_Leap_Year := False;
  348.      If (Year = 0) and
  349.         (Century = (Trunc (Int (Century / 4)) * 4)) and
  350.         (Century <> (Trunc (Int (Century / 10)) * 10)) then
  351.            PTOOLDAT_Leap_Year := False;
  352. End;
  353.  
  354.  
  355. Function PTOOLDAT_G_Check (Test : PTOOLDAT_Str_21;
  356.                            OrderIn : PTOOLDAT_Str_3)
  357.                           : Boolean;
  358.  
  359. Var                                      { Find out if the Element areas    }
  360.    Num_of_El : Integer;                  { represent a valid Gregorian date }
  361.    E         : Byte;                     { and set Number areas             }
  362.    Ok        : Boolean;
  363.  
  364. Begin
  365.      Ok := True;
  366.      PTOOLDAT_Parse (Test, Num_of_El);
  367.      If Num_of_El <> 3 then
  368.         Ok := False;
  369.      For E := 1 to 3 do
  370.          Begin
  371.               PTOOLDAT_Number [E] := PTOOLDAT_GetNum (PTOOLDAT_Element [E],
  372.                                                       OrderIn [E]);
  373.               If PTOOLDAT_Number [E] = 0 then Ok := False;
  374.          End;
  375.      If Ok = True then
  376.         Begin
  377.              For E := 1 to 3 do
  378.                  Case OrderIn [E] of
  379.                   'Y' : PTOOLDAT_NumY := PTOOLDAT_Number [E];
  380.                   'M' : PTOOLDAT_NumM := PTOOLDAT_Number [E];
  381.                   'D' : PTOOLDAT_NumD := PTOOLDAT_Number [E];
  382.                   End; {Case}
  383.              If PTOOLDAT_NumD > 30 then
  384.                 If not (PTOOLDAT_NumM in [1, 3, 5, 7, 8, 10, 12]) then
  385.                    Ok := False;
  386.              If (PTOOLDAT_NumD > 29) and
  387.                 (PTOOLDAT_NumM = 2) then Ok := False;
  388.              If (PTOOLDAT_NumD > 28) and
  389.                 (PTOOLDAT_NumM = 2) and
  390.                 (PTOOLDAT_Leap_Year (PTOOLDAT_NumY) = False) then
  391.                 Ok := False;
  392.         End;
  393.      PTOOLDAT_G_Check := Ok;
  394. End;
  395.  
  396.  
  397. Function PTOOLDAT_Make_G : PTOOLDAT_Str_21;
  398.  
  399. Var                              { Transform the Number & Element areas }
  400.    E      : Byte;                { into a Gregorian date                }
  401.    Output : String [21];
  402.  
  403. Begin
  404.      If PTOOLDAT_G_YrDisp = 2 then
  405.         Str (PTOOLDAT_NumY - (Trunc (Int (PTOOLDAT_NumY / 100)) * 100):2,
  406.              PTOOLDAT_ElY)
  407.      else
  408.         Str (PTOOLDAT_NumY:4, PTOOLDAT_ElY);
  409.      If PTOOLDAT_ElY [1] = ' ' then PTOOLDAT_ElY [1] := '0';
  410.      Case PTOOLDAT_G_MoDisp of
  411.       2 : Begin
  412.                Str (PTOOLDAT_NumM:2, PTOOLDAT_ElM);
  413.                If PTOOLDAT_ElM [1] = ' ' then
  414.                   If PTOOLDAT_G_ZeroSup then Delete (PTOOLDAT_ElM, 1, 1)
  415.                                         else PTOOLDAT_ElM [1] := '0';
  416.           End;
  417.       3 : PTOOLDAT_ElM := PTOOLDAT_Mon [PTOOLDAT_NumM];
  418.       9 : PTOOLDAT_ElM := PTOOLDAT_Month [PTOOLDAT_NumM];
  419.      End; {Case}
  420.      Str (PTOOLDAT_NumD:2, PTOOLDAT_ElD);
  421.      If PTOOLDAT_ElD [1] = ' ' then
  422.         If PTOOLDAT_G_ZeroSup then Delete (PTOOLDAT_ElD, 1, 1)
  423.                               else PTOOLDAT_ElD [1] := '0';
  424.      Output := '';
  425.      For E := 1 to 3 do
  426.          Begin
  427.               Case PTOOLDAT_G_Order [E] of
  428.                'Y' : Output := Output + PTOOLDAT_ElY;
  429.                'M' : Output := Output + PTOOLDAT_ElM;
  430.                'D' : Output := Output + PTOOLDAT_ElD;
  431.                End; {Case}
  432.               Case E of
  433.                1 : Output := Output + PTOOLDAT_G_Sep1;
  434.                2 : Output := Output + PTOOLDAT_G_Sep2;
  435.                End; {Case}
  436.          End;
  437.      PTOOLDAT_Make_G := Output;
  438. End;
  439.  
  440.  
  441. Function PTOOLDAT_G_Convert (Test  : PTOOLDAT_Str_21;
  442.                              OrderIn, OrderOut : PTOOLDAT_Str_3)
  443.                             : PTOOLDAT_Str_21;
  444.  
  445. Begin                                               { Transform date formats }
  446.      PTOOLDAT_G_Convert := ' ';
  447.      If PTOOLDAT_G_Check (Test, OrderIn) then
  448.         PTOOLDAT_G_Convert := PTOOLDAT_Make_G;
  449. End;
  450.  
  451.  
  452. Function PTOOLDAT_Day_of_Year : Integer;
  453.  
  454. Var                                           { Get Day of Year }
  455.    Result : Integer;
  456.  
  457. Const
  458.      Days : Array [1..12] of Integer = (0, 31, 59, 90, 120, 151, 181, 212,
  459.                                         243, 273, 304, 334);
  460.  
  461. Begin
  462.       Result := Days [PTOOLDAT_NumM] + PTOOLDAT_NumD;
  463.       If (PTOOLDAT_NumM > 2) and
  464.          (PTOOLDAT_Leap_Year (PTOOLDAT_NumY)) then
  465.          Result := Result + 1;
  466.       PTOOLDAT_Day_of_Year := Result;
  467. End;
  468.  
  469.  
  470. Function PTOOLDAT_J_Type_E : Real;
  471.  
  472. Var                                        { Get 'E' type Julian Date from }
  473.    Accum : Real;                           { Number area                   }
  474.    I, J  : Integer;
  475.  
  476. Begin
  477.      If PTOOLDAT_BaseYear <= PTOOLDAT_NumY then
  478.         Begin
  479.              J := Trunc ( Int((PTOOLDAT_NumY - PTOOLDAT_BaseYear) / 4));
  480.              Accum := Int (J) * 1461;
  481.              I := PTOOLDAT_BaseYear + (J * 4);
  482.              While I < PTOOLDAT_NumY do
  483.                    Begin
  484.                         If PTOOLDAT_Leap_Year (I) then Accum := Accum + 366
  485.                                                   else Accum := Accum + 365;
  486.                         I := I + 1;
  487.                   End;
  488.              PTOOLDAT_J_Type_E := Accum + PTOOLDAT_Day_of_Year - 1;
  489.         End
  490.      else
  491.         Begin
  492.              If PTOOLDAT_Leap_Year (PTOOLDAT_NumY) then
  493.                 Accum := 367 - PTOOLDAT_Day_of_Year
  494.              else
  495.                 Accum := 366 - PTOOLDAT_Day_of_Year;
  496.              J := Trunc ( Int ((PTOOLDAT_BaseYear - PTOOLDAT_NumY) / 4));
  497.              Accum := Accum + (Int (J) * 1461);
  498.              I := PTOOLDAT_NumY + 1 + (J * 4);
  499.              While I < PTOOLDAT_BaseYear do
  500.                    Begin
  501.                         If PTOOLDAT_Leap_Year (I) then Accum := Accum + 366
  502.                                                   else Accum := Accum + 365;
  503.                         I := I + 1;
  504.                    End;
  505.              PTOOLDAT_J_Type_E := Accum * -1;
  506.         End;
  507. End;
  508.  
  509.  
  510. Procedure PTOOLDAT_Set_M_D (Input : Real);
  511.  
  512. Var                                               { Get Month & Day }
  513.    InInt    : Integer;                            { from DDD        }
  514.    I        : Byte;
  515.    J        : Integer;
  516.    DayTest  : Array [1..12] of Integer;
  517.  
  518. Const
  519.      Days : Array [1..12] of Integer = (0, 31, 59, 90, 120, 151, 181, 212,
  520.                                         243, 273, 304, 334);
  521.  
  522. Begin
  523.      InInt := Trunc (Input - ((Int (Trunc (Input / 1000))) * 1000));
  524.      Move (Days, DayTest, 24);
  525.      If PTOOLDAT_Leap_Year (PTOOLDAT_NumY) then
  526.         For I := 3 to 12 do
  527.             DayTest [I] := DayTest [I] + 1;
  528.      For I := 1 to 12 do
  529.          If InInt > DayTest [I] then
  530.             Begin
  531.                  PTOOLDAT_NumM := I;
  532.                  J := DayTest [I];
  533.             End;
  534.      PTOOLDAT_NumD := InInt - J;
  535. End;
  536.  
  537.  
  538. Procedure PTOOLDAT_J_E_Eval (Input : Real);
  539.                                                 { Convert a Julian type 'E' }
  540. Var                                             { date to Number area       }
  541.    Years, Days  : Integer;
  542.    I            : Byte;
  543.    Test         : Integer;
  544.  
  545. Begin
  546.      If Input >= 0 then
  547.         Begin
  548.              Years := Trunc (Input / 1461);
  549.              Days := Trunc (Input - (Int (Years) * 1461)) + 1;
  550.              PTOOLDAT_NumY := PTOOLDAT_BaseYear;
  551.              For I := 1 to 4 do
  552.                  Begin
  553.                       If PTOOLDAT_Leap_Year (PTOOLDAT_NumY) then Test := 366
  554.                                                             else Test := 365;
  555.                       If Days > Test then
  556.                          Begin
  557.                               Days := Days - Test;
  558.                               PTOOLDAT_NumY := PTOOLDAT_NumY + 1;
  559.                          End;
  560.                  End;
  561.              PTOOLDAT_NumY := PTOOLDAT_NumY + (Years * 4);
  562.         End
  563.      else
  564.         Begin
  565.              Input := Input * -1;
  566.              Years := Trunc (Input / 1461);
  567.              Days := Trunc (Input - (Int (Years) * 1461));
  568.              PTOOLDAT_NumY := PTOOLDAT_BaseYear - 1;
  569.              For I := 1 to 4 do
  570.                  Begin
  571.                       If PTOOLDAT_Leap_Year (PTOOLDAT_NumY) then Test := 366
  572.                                                             else Test := 365;
  573.                       If Days > Test then
  574.                          Begin
  575.                               Days := Days - Test;
  576.                               PTOOLDAT_NumY := PTOOLDAT_NumY - 1;
  577.                          End;
  578.                  End;
  579.              PTOOLDAT_NumY := PTOOLDAT_NumY - (Years * 4);
  580.              If PTOOLDAT_Leap_Year (PTOOLDAT_NumY) then Days := 367 - Days
  581.                                                    else Days := 366 - Days;
  582.         End;
  583.      PTOOLDAT_Set_M_D (Days);
  584. End;
  585.  
  586.  
  587. Procedure PTOOLDAT_J_AB_Set_Y (Input : Real);     { Put Year in Number area }
  588.                                                   { From YYmmm              }
  589. Begin
  590.      PTOOLDAT_NumY := Trunc (Input / 1000);
  591.      If PTOOLDAT_NumY < 100 then
  592.         PTOOLDAT_NumY := PTOOLDAT_Set_Century (PTOOLDAT_NumY);
  593. End;
  594.  
  595.  
  596. Function PTOOLDAT_Get_Jul : Real;
  597.                                           { Get Julian Date from Number area }
  598. Begin
  599.      Case PTOOLDAT_J_Type of
  600.       'A' : PTOOLDAT_Get_Jul := (Int (PTOOLDAT_NumY) * 1000)
  601.                               - (Int (PTOOLDAT_NumY / 100) * 100000.0)
  602.                               + Int (PTOOLDAT_Day_of_Year);
  603.       'B' : PTOOLDAT_Get_Jul := (Int (PTOOLDAT_NumY) * 1000)
  604.                               + Int (PTOOLDAT_Day_of_Year);
  605.       'E' : PTOOLDAT_Get_Jul := PTOOLDAT_J_Type_E;
  606.       End; {Case}
  607. End;
  608.  
  609.  
  610. Function PTOOLDAT_Get_S : Integer;
  611.                                       { Get Short date from Number area }
  612. Var
  613.    Julian : Real;
  614.  
  615. Const
  616.      MaxJul : Real = 65532.0;
  617.  
  618. Begin
  619.      Julian := PTOOLDAT_J_Type_E;
  620.      If (Julian >= 0) and
  621.         (Julian <= MaxJul) then PTOOLDAT_Get_S := Trunc (Julian - 32765)
  622.                            else PTOOLDAT_Get_S := -32766;
  623. End;
  624.  
  625.  
  626. Function PTOOLDAT_DOW (Day : Integer) : PTOOLDAT_Str_9;
  627.  
  628. Var
  629.    Hold_DOW : PTOOLDAT_Str_9;                     { Convert 1 - 7 to day }
  630.                                                   { of week verbage      }
  631. Begin
  632.      Case PTOOLDAT_Day_Type of
  633.       1 : Begin
  634.                Str (Day:1, Hold_DOW);
  635.                PTOOLDAT_DOW := Hold_DOW;
  636.           End;
  637.       3 : PTOOLDAT_DOW := PTOOLDAT_Day [Day];
  638.       9 : PTOOLDAT_DOW := PTOOLDAT_DayOW [Day];
  639.       End; {Case}
  640. End;
  641.  
  642.  
  643. Function PTOOLDAT_Get_Date : PTOOLDAT_Str_21;
  644.  
  645. Type                                         { BIOS call to get current date }
  646.     BiosCall = Record
  647.                Ax, Bx, Cx, Dx, Bp, Si, Ds, Es, Flags : Integer;
  648.                End;
  649.  
  650. Var
  651.     BiosRec          : BiosCall;
  652.     Year, Month, Day : String [4];
  653.  
  654. Begin
  655.      With BiosRec do
  656.           Begin
  657.                Ax := $2a shl 8;
  658.           End;
  659.      MsDos (BiosRec);
  660.      With BiosRec do
  661.           Begin
  662.                Str (Cx, Year);
  663.                Str (Dx mod 256, Day);
  664.                Str (Dx shr 8, Month);
  665.           End;
  666.      PTOOLDAT_Get_Date := Year + ' ' + Month + ' ' + Day;
  667. End;
  668.  
  669.  
  670. {Called Functions Begin Here ******************************************** }
  671.  
  672.  
  673. FUNCTION PTDGValid (Test : PTOOLDAT_Str_21) : Boolean;
  674.  
  675. BEGIN
  676.  
  677.      PTDGValid := PTOOLDAT_G_Check (Test, PTOOLDAT_G_Order);
  678.  
  679. END;
  680.  
  681.  
  682. FUNCTION PTDJValid (Test : Real) : Boolean;
  683.  
  684. VAR
  685.  
  686.    Year   : Integer;
  687.    Day    : Integer;
  688.    Ok     : Boolean;
  689.  
  690. BEGIN
  691.  
  692.      Ok := True;
  693.      Case PTOOLDAT_J_Type of
  694.       'A' : If (Test < 1.0) or
  695.                (Test > 99365.0) then Ok := False;
  696.       'B' : If (Test < 1.0) or
  697.                (Test > 9999365.0) then Ok := False;
  698.       End; {Case}
  699.      PTDJValid := Ok;
  700.      If (Ok = True) and
  701.         (PTOOLDAT_J_Type <> 'E') then
  702.         Begin
  703.              Year := Trunc (Test / 1000);
  704.              Day := Trunc (Test - (Int (Year) * 1000));
  705.              If (Day > 366)
  706.              or ((Day = 366) and
  707.                  (PTOOLDAT_Leap_Year (Year) = False))
  708.              or (Day = 0) then
  709.                 PTDJValid := False;
  710.         End;
  711.  
  712. END;
  713.  
  714.  
  715. FUNCTION PTDSValid (Short : Integer) : Boolean;
  716.  
  717. BEGIN
  718.  
  719.      If Short <> -32766 then PTDSValid := True
  720.                         else PTDSValid := False
  721.  
  722. END;
  723.  
  724.  
  725. FUNCTION PTDGtoJ (Input : PTOOLDAT_Str_21) : Real;
  726.  
  727. BEGIN
  728.  
  729.      If PTOOLDAT_G_Check (Input, PTOOLDAT_G_Order) then
  730.         PTDGtoJ := PTOOLDAT_Get_Jul;
  731.  
  732. END;
  733.  
  734.  
  735. FUNCTION PTDJtoG (Input : Real) : PTOOLDAT_Str_21;
  736.  
  737. BEGIN
  738.  
  739.      PTDJtoG := ' ';
  740.      If PTOOLDAT_J_Type = 'E' then PTOOLDAT_J_E_Eval (Input)
  741.      else
  742.         Begin
  743.              PTOOLDAT_J_AB_Set_Y (Input);
  744.              PTOOLDAT_NumY := Trunc (Input / 1000);
  745.              If PTOOLDAT_NumY < 100 then
  746.                 PTOOLDAT_NumY := PTOOLDAT_Set_Century (PTOOLDAT_NumY);
  747.              PTOOLDAT_Set_M_D (Input);
  748.         End;
  749.      PTDJtoG := PTOOLDAT_Make_G;
  750.  
  751. END;
  752.  
  753.  
  754. FUNCTION PTDGtoG (Input : PTOOLDAT_Str_21) : PTOOLDAT_Str_21;
  755.  
  756. BEGIN
  757.  
  758.      If PTOOLDAT_G_Check (Input, PTOOLDAT_G2_Order) then
  759.         PTDGtoG := PTOOLDAT_Make_G
  760.      else
  761.         PTDGtoG := ' ';
  762.  
  763. END;
  764.  
  765.  
  766. FUNCTION PTDGtoS (Input : PTOOLDAT_Str_21) : Integer;
  767.  
  768. BEGIN
  769.  
  770.      If PTOOLDAT_G_Check (Input, PTOOLDAT_G_Order) then
  771.         PTDGtoS := PTOOLDAT_Get_S
  772.      else
  773.         PTDGtoS := -32766;
  774.  
  775. END;
  776.  
  777.  
  778. FUNCTION PTDStoG (Short : Integer) : PTOOLDAT_Str_21;
  779.  
  780. BEGIN
  781.  
  782.      If PTDSValid (Short) = False then PTDStoG := ' '
  783.      else
  784.         Begin
  785.              PTOOLDAT_J_E_Eval (Int (Short) + 32765);
  786.              PTDStoG := PTOOLDAT_Make_G;
  787.         End
  788.  
  789. END;
  790.  
  791.  
  792. FUNCTION PTDJtoS (Input : Real) : Integer;
  793.  
  794. CONST
  795.  
  796.      MaxJul : Real = 65532.0;
  797.  
  798. BEGIN
  799.  
  800.      PTDJtoS := -32766;
  801.      If PTOOLDAT_J_TYPE in ['A', 'B'] then
  802.         Begin
  803.              PTOOLDAT_J_AB_Set_Y (Input);
  804.              PTOOLDAT_Set_M_D (Input);
  805.              PTDJtoS := PTOOLDAT_Get_S;
  806.         End
  807.      else
  808.         If (Input >= 0) and
  809.            (Input <= MaxJul) then PTDJtoS := Trunc (Input - 32765);
  810.  
  811. END;
  812.  
  813.  
  814. FUNCTION PTDStoJ (Short : Integer) : Real;
  815.  
  816. VAR
  817.  
  818.    Julian_E : Real;
  819.  
  820. BEGIN
  821.  
  822.      Julian_E := Int (Short) + 32765;
  823.      If PTDSValid (Short) then
  824.         If PTOOLDAT_J_Type = 'E' then
  825.            PTDStoJ := Julian_E
  826.         else
  827.            Begin
  828.                 PTOOLDAT_J_E_Eval (Julian_E);
  829.                 PTDStoJ := PTOOLDAT_Get_Jul;
  830.            End;
  831.  
  832. END;
  833.  
  834.  
  835. FUNCTION PTDGAdd (Input : PTOOLDAT_Str_21;
  836.                   Number : Integer) : PTOOLDAT_Str_21;
  837.  
  838. BEGIN
  839.  
  840.      If PTOOLDAT_G_Check (Input, PTOOLDAT_G_Order) then
  841.         Begin
  842.              PTOOLDAT_J_E_Eval (PTOOLDAT_J_Type_E + Int (Number));
  843.              PTDGAdd := PTOOLDAT_Make_G;
  844.         End;
  845.  
  846. END;
  847.  
  848.  
  849. FUNCTION PTDJAdd (Input : Real; Number : Integer) : Real;
  850.  
  851. BEGIN
  852.  
  853.      If PTOOLDAT_J_Type = 'E' then
  854.         PTDJAdd := (Input + Int (Number))
  855.     else
  856.         Begin
  857.              PTOOLDAT_J_AB_Set_Y (Input);
  858.              PTOOLDAT_Set_M_D (Input);
  859.              PTOOLDAT_J_E_Eval (PTOOLDAT_J_Type_E + Int (Number));
  860.              PTDJAdd := PTOOLDAT_Get_Jul;
  861.         End;
  862.  
  863. END;
  864.  
  865.  
  866. FUNCTION PTDGComp (Minuend, Subtrahend : PTOOLDAT_Str_21) : Real;
  867.  
  868. VAR
  869.    Hold_Jul_Type : Char;
  870.  
  871. BEGIN
  872.  
  873.      Hold_Jul_Type := PTOOLDAT_J_Type;
  874.      PTOOLDAT_J_Type := 'E';
  875.      PTDGComp := PTDGtoJ (Minuend) - PTDGtoJ (Subtrahend);
  876.      PTOOLDAT_J_Type := Hold_Jul_Type;
  877.  
  878. END;
  879.  
  880. FUNCTION PTDJComp (Minuend, Subtrahend : Real) : Real;
  881.  
  882. VAR
  883.  
  884.    Hold_Jul : Real;
  885.  
  886. BEGIN
  887.  
  888.      If PTOOLDAT_J_Type = 'E' then PTDJComp := Minuend - Subtrahend
  889.      else
  890.         Begin
  891.              PTOOLDAT_J_AB_Set_Y (Minuend);
  892.              PTOOLDAT_Set_M_D (Minuend);
  893.              Hold_Jul := (PTOOLDAT_J_Type_E);
  894.              PTOOLDAT_J_AB_Set_Y (Subtrahend);
  895.              PTOOLDAT_Set_M_D (Subtrahend);
  896.              PTDJComp := Hold_Jul - (PTOOLDAT_J_Type_E);
  897.         End;
  898.  
  899. END;
  900.  
  901.  
  902. FUNCTION PTDGLeap (Input : PTOOLDAT_Str_21) : Boolean;
  903.  
  904. BEGIN
  905.  
  906.      If PTOOLDAT_G_Check (Input, PTOOLDAT_G_Order) then
  907.         PTDGLeap := PTOOLDAT_Leap_Year (PTOOLDAT_NumY)
  908.      else
  909.         PTDGLeap := False;
  910.  
  911. END;
  912.  
  913.  
  914. FUNCTION PTDJLeap (Input : Real) : Boolean;
  915.  
  916. BEGIN
  917.  
  918.      If PTOOLDAT_J_Type = 'E' then
  919.         PTOOLDAT_J_E_Eval (Input)
  920.      else
  921.         PTOOLDAT_J_AB_Set_Y (Input);
  922.      PTDJLeap := PTOOLDAT_Leap_Year (PTOOLDAT_NumY);
  923.  
  924. END;
  925.  
  926.  
  927. FUNCTION PTDSLeap (Input : Integer) : Boolean;
  928.  
  929. BEGIN
  930.  
  931.      If PTDSValid (Input) = False then PTDSLeap := False
  932.      else
  933.         Begin
  934.              PTOOLDAT_J_E_Eval (Int (Input) + 32765);
  935.              PTDSLeap := PTOOLDAT_Leap_Year (PTOOLDAT_NumY);
  936.         End;
  937.  
  938. END;
  939.  
  940.  
  941. FUNCTION PTDYLeap (Input : Integer) : Boolean;
  942.  
  943. BEGIN
  944.  
  945.      PTDYLeap := PTOOLDAT_Leap_Year (Input);
  946.  
  947. END;
  948.  
  949.  
  950. FUNCTION PTDGDay (Input : PTOOLDAT_Str_21) : PTOOLDAT_Str_9;
  951.  
  952. VAR
  953.  
  954.    Hold_Base_Year : Integer;
  955.    Hold_Jul_Type    : Char;
  956.    Day            : Integer;
  957.  
  958. BEGIN
  959.  
  960.      Hold_Base_Year := PTOOLDAT_BaseYear;
  961.      PTOOLDAT_BaseYear := 0100;
  962.      Hold_Jul_Type := PTOOLDAT_J_Type;
  963.      PTOOLDAT_J_Type := 'E';
  964.      Day := Trunc (Frac (PTDGtoJ (Input) / 7) * 7.001) + 1;
  965.      PTDGDay := PTOOLDAT_DOW (Day);
  966.      PTOOLDAT_BaseYear := Hold_Base_Year;
  967.      PTOOLDAT_J_Type := Hold_Jul_Type;
  968.  
  969. END;
  970.  
  971.  
  972. FUNCTION PTDJDay (Input : Real) : PTOOLDAT_Str_9;
  973.  
  974. BEGIN
  975.  
  976.      PTDJDay := PTDGDay (PTDJtoG (Input));
  977.  
  978. END;
  979.  
  980.  
  981. FUNCTION PTDSDay (Input : Integer) : PTOOLDAT_Str_9;
  982.  
  983. BEGIN
  984.  
  985.      PTDSDay := PTDGDay (PTDStoG (Input));
  986.  
  987. END;
  988.  
  989.  
  990. FUNCTION PTDGCurr : PTOOLDAT_Str_21;
  991.  
  992. BEGIN
  993.  
  994.      PTDGCurr := PTOOLDAT_G_Convert (PTOOLDAT_Get_Date,
  995.                                      'YMD', PTOOLDAT_G_Order);
  996.  
  997. END;
  998.  
  999.  
  1000. FUNCTION PTDJCurr : Real;
  1001.  
  1002. BEGIN
  1003.  
  1004.      PTDJCurr := PTDGtoJ (PTDGCurr);
  1005.  
  1006. END;
  1007.  
  1008.  
  1009. FUNCTION PTDSCurr : Integer;
  1010.  
  1011. BEGIN
  1012.  
  1013.      PTDSCurr := PTDGtoS (PTDGCurr);
  1014.  
  1015. END;
  1016.